perm filename PK.TYP[NEW,LCS] blob
sn#561091 filedate 1981-02-01 generic text, type T, neo UTF8
00100 DIMENSION V(4000),Q(4000),R(128)
00200 EQUIVALENCE (JT,R(19)),(JF,R(18))
00300 C JF IS FLAG FOR NEW PACKING MODE (=-1 IF NEW, =>0 IF OLD)
00400 10 FORMAT(I)
00500 11 FORMAT(F13.3)
00600 CALL GETEXT('AAAAA','MS')
00700 CALL EXTIN(R,128)
00800 CALL EXTIN(V,JT)
00900 CALL PUTEXT('ZZZZZ','MS')
01000 I=0
01100 N=1
01200 1 J=V(N+1)
01250 L=V(N)
01300 NX=L+3+N
01400 LX=NX
01410 9 IF(L.LT.2)GO TO 12
01420 IF(V(LX-1).NE.0)GO TO 12
01430 C GET RID OF TRAILING ZERO PARAMS (AFTER P3)
01440 V(N)=V(N)-1
01450 LX=LX-1
01460 L=L-1
01470 GO TO 9
01500 12 CALL STUFIT(V,N,I)
01600 C MOVES N UP 4 COUNTS
01700 TYPE 10,V(I)
01750 GO TO 16
01775 C***** SKIP NEXT BECAUSE OF ROUND OFF ERRORS WHEN RETRIEVING.
01800 IF(J.EQ.16)GO TO 16
01820 IF(J.EQ.8)GO TO 16
01840 IF(J.EQ.11)GO TO 16
01900 C CATCH 'WORDS' AND PARAMS THAT MIGHT HAVE ASCII IN THEM.
02000 M=3
02100 3 IF(N.EQ.NX)GO TO 2
02200 M=M+1
02300 C UPDATE PARAM NUM.
02400 IF(V(N).NE.0)GO TO 4
02500 C SKIP ZERO PARAMS
02600 6 N=N+1
02700 GO TO 3
02800 4 I=I+1
02900 C UPDATE OUTPUT CNTR
03000 X=10000.0
03100 IF(V(N).LT.0)X=-X
03200 V(I)=V(N)+M*X
03300 C PUT PARAM NUMBER ON FRONT OF WD
03400 TYPE 11,V(I)
03500 GO TO 6
03600 16 IF(N.EQ.LX)GO TO 13
03620 DO 5 K=N,LX-1
03700 I=I+1
03800 TYPE 11,V(K)
03900 5 V(I)=V(K)
04000 13 N=NX
04100 2 IF(N.LT.JT)GO TO 1
04200 JT=I
04300 C DONE NOW
04400 CALL EXTOUT(R,128)
04500 CALL EXTOUT(V,I)
04600 CALL FINEXT
04700 PAUSE
04800
04900 C NOW GET IT ALL BACK
05000 100 CALL GETEXT('ZZZZZ','MS')
05100 CALL EXTIN(R,128)
05200 CALL EXTIN(Q,JT)
05300 CALL PUTEXT('XXXXX','MS')
05400 I=0
05500 N=1
05700 20 CALL UNSTUF(Q,I,V,N)
05800 TYPE 11,V(N-4),V(N-3),V(N-2),V(N-1)
05900 J=V(N-3)
06000 C GET THE CODE NUM.
06100 NX=V(N-4)-1+N
06200 C HOW FAR DO WE GO FOR THIS ITEM?
06250 GO TO 36
06260 C***** SKIP NEXT BECAUSE OF ROUND OFF ERRORS WHEN RETRIEVING.
06300 IF(J.EQ.16)GO TO 36
06320 IF(J.EQ.8)GO TO 36
06340 IF(J.EQ.11)GO TO 36
06360 M=3
06380 22 IF(N.EQ.NX)GO TO 32
06390 M=M+1
06400 I=I+1
06500 L=Q(I)/10000.0
06600 C GET THE PARAM NUM.
06700 LL=IABS(L)
06900 24 IF(LL.EQ.M)GO TO 21
07000 IF(N.NE.NX)GO TO 25
07050 I=I-1
07075 GO TO 32
07100 25 V(N)=0
07200 C PUT BACK IN THE ZERO PARAMS.
07300 TYPE 11,V(N)
07350 M=M+1
07400 23 N=N+1
07500 GO TO 24
07600 21 X=Q(I)-L*10000
07700 C GET BACK THE REAL CONTENTS OF THE PARAM.
07900 V(N)=X
07925 TYPE 11,X
07950 N=N+1
08000 GO TO 22
08100 36 IF(N.EQ.NX)GO TO 32
08120 DO 35 K=N,NX-1
08200 I=I+1
08300 TYPE 11,Q(I)
08400 35 V(K)=Q(I)
08500 N=NX
08600 32 IF(I.LT.JT)GO TO 20
08700 JT=N
08800 CALL EXTOUT(R,128)
08900 CALL EXTOUT(V,N)
09000 CALL FINEXT
09100
09200 END